home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 018 / xlisp1.6 / xlread.c < prev    next >
C/C++ Source or Header  |  1995-03-17  |  15KB  |  742 lines
  1. /* xlread - xlisp expression input routine */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *s_stdout,*true,*s_dot;
  14. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  15. extern NODE *s_rtable,*k_wspace,*k_const,*k_nmacro,*k_tmacro;
  16. extern NODE ***xlstack;
  17. extern int xlplevel;
  18. extern char buf[];
  19.  
  20. /* external routines */
  21. extern FILE *fopen();
  22. extern double atof();
  23. extern ITYPE;
  24.  
  25. #define WSPACE "\t \f\r\n"
  26. #define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
  27. #define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
  28.  
  29. /* forward declarations */
  30. FORWARD NODE *callmacro();
  31. FORWARD NODE *phexnumber(),*pquote(),*plist(),*pvector(),*pname();
  32. FORWARD NODE *tentry();
  33.  
  34. /* xlload - load a file of xlisp expressions */
  35. int xlload(fname,vflag,pflag)
  36.   char *fname; int vflag,pflag;
  37. {
  38.     NODE ***oldstk,*fptr,*expr;
  39.     char fullname[STRMAX+1];
  40.     CONTEXT cntxt;
  41.     FILE *fp;
  42.     int sts;
  43.  
  44.     /* create a new stack frame */
  45.     oldstk = xlsave(&fptr,&expr,NULL);
  46.  
  47.     /* create the full file name */
  48.     if (needsextension(fname)) {
  49.     strcpy(fullname,fname);
  50.     strcat(fullname,".lsp");
  51.     fname = fullname;
  52.     }
  53.  
  54.     /* allocate a file node */
  55.     fptr = cvfile(NULL);
  56.  
  57.     /* print the information line */
  58.     if (vflag)
  59.     { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
  60.  
  61.     /* open the file */
  62.     if ((fp = fopen(fname,"r")) == NULL) {
  63.     xlstack = oldstk;
  64.     return (FALSE);
  65.     }
  66.     setfile(fptr,fp);
  67.  
  68.     /* read, evaluate and possibly print each expression in the file */
  69.     xlbegin(&cntxt,CF_ERROR,true);
  70.     if (setjmp(cntxt.c_jmpbuf))
  71.     sts = FALSE;
  72.     else {
  73.     while (xlread(fptr,&expr,FALSE)) {
  74.         expr = xleval(expr);
  75.         if (pflag)
  76.         stdprint(expr);
  77.     }
  78.     sts = TRUE;
  79.     }
  80.     xlend(&cntxt);
  81.  
  82.     /* close the file */
  83.     fclose(getfile(fptr));
  84.     setfile(fptr,NULL);
  85.  
  86.     /* restore the previous stack frame */
  87.     xlstack = oldstk;
  88.  
  89.     /* return status */
  90.     return (sts);
  91. }
  92.  
  93. /* xlread - read an xlisp expression */
  94. int xlread(fptr,pval,rflag)
  95.   NODE *fptr,**pval; int rflag;
  96. {
  97.     int sts;
  98.  
  99.     /* reset the paren nesting level */
  100.     if (!rflag)
  101.     xlplevel = 0;
  102.  
  103.     /* read an expression */
  104.     while ((sts = readone(fptr,pval)) == FALSE)
  105.     ;
  106.  
  107.     /* return status */
  108.     return (sts == EOF ? FALSE : TRUE);
  109. }
  110.  
  111. /* readone - attempt to read a single expression */
  112. int readone(fptr,pval)
  113.   NODE *fptr,**pval;
  114. {
  115.     NODE *val,*type;
  116.     int ch;
  117.  
  118.     /* get a character and check for EOF */
  119.     if ((ch = xlgetc(fptr)) == EOF)
  120.     return (EOF);
  121.  
  122.     /* handle white space */
  123.     if ((type = tentry(ch)) == k_wspace)
  124.     return (FALSE);
  125.  
  126.     /* handle symbol constituents */
  127.     else if (type == k_const) {
  128.     *pval = pname(fptr,ch);
  129.     return (TRUE);
  130.     }
  131.  
  132.     /* handle read macros */
  133.     else if (consp(type)) {
  134.     if ((val = callmacro(fptr,ch)) && consp(val)) {
  135.         *pval = car(val);
  136.         return (TRUE);
  137.     }
  138.     else
  139.         return (FALSE);
  140.     }
  141.  
  142.     /* handle illegal characters */
  143.     else
  144.     xlerror("illegal character",cvfixnum((FIXNUM)ch));
  145. }
  146.  
  147. /* rmhash - read macro for '#' */
  148. NODE *rmhash(args)
  149.   NODE *args;
  150. {
  151.     NODE ***oldstk,*fptr,*mch,*val;
  152.     int ch;
  153.  
  154.     /* create a new stack frame */
  155.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  156.  
  157.     /* get the file and macro character */
  158.     fptr = xlgetfile(&args);
  159.     mch = xlmatch(INT,&args);
  160.     xllastarg(args);
  161.  
  162.     /* make the return value */
  163.     val = consa(NIL);
  164.  
  165.     /* check the next character */
  166.     switch (ch = xlgetc(fptr)) {
  167.     case '\'':
  168.         rplaca(val,pquote(fptr,s_function));
  169.         break;
  170.     case '(':
  171.         rplaca(val,pvector(fptr));
  172.         break;
  173.     case 'x':
  174.     case 'X':
  175.             rplaca(val,phexnumber(fptr));
  176.         break;
  177.     case '\\':
  178.         rplaca(val,cvfixnum((FIXNUM)xlgetc(fptr)));
  179.         break;
  180.     default:
  181.         xlerror("illegal character after #",cvfixnum((FIXNUM)ch));
  182.     }
  183.  
  184.     /* restore the previous stack frame */
  185.     xlstack = oldstk;
  186.  
  187.     /* return the value */
  188.     return (val);
  189. }
  190.  
  191. /* rmquote - read macro for '\'' */
  192. NODE *rmquote(args)
  193.   NODE *args;
  194. {
  195.     NODE ***oldstk,*fptr,*mch,*val;
  196.  
  197.     /* create a new stack frame */
  198.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  199.  
  200.     /* get the file and macro character */
  201.     fptr = xlgetfile(&args);
  202.     mch = xlmatch(INT,&args);
  203.     xllastarg(args);
  204.  
  205.     /* make the return value */
  206.     val = consa(NIL);
  207.     rplaca(val,pquote(fptr,s_quote));
  208.  
  209.     /* restore the previous stack frame */
  210.     xlstack = oldstk;
  211.  
  212.     /* return the value */
  213.     return (val);
  214. }
  215.  
  216. /* rmdquote - read macro for '"' */
  217. NODE *rmdquote(args)
  218.   NODE *args;
  219. {
  220.     NODE ***oldstk,*fptr,*mch,*val;
  221.     int ch,i,d1,d2,d3;
  222.  
  223.     /* create a new stack frame */
  224.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  225.  
  226.     /* get the file and macro character */
  227.     fptr = xlgetfile(&args);
  228.     mch = xlmatch(INT,&args);
  229.     xllastarg(args);
  230.  
  231.     /* loop looking for a closing quote */
  232.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  233.     switch (ch) {
  234.     case '\\':
  235.         switch (ch = checkeof(fptr)) {
  236.         case 'f':
  237.             ch = '\f';
  238.             break;
  239.         case 'n':
  240.             ch = '\n';
  241.             break;
  242.         case 'r':
  243.             ch = '\r';
  244.             break;
  245.         case 't':
  246.             ch = '\t';
  247.             break;
  248.         default:
  249.             if (ch >= '0' && ch <= '7') {
  250.                 d1 = ch - '0';
  251.                 d2 = checkeof(fptr) - '0';
  252.                 d3 = checkeof(fptr) - '0';
  253.                 ch = (d1 << 6) + (d2 << 3) + d3;
  254.             }
  255.             break;
  256.         }
  257.     }
  258.     buf[i] = ch;
  259.     }
  260.     buf[i] = 0;
  261.  
  262.     /* initialize the node */
  263.     val = consa(NIL);
  264.     rplaca(val,cvstring(buf));
  265.  
  266.     /* restore the previous stack frame */
  267.     xlstack = oldstk;
  268.  
  269.     /* return the new string */
  270.     return (val);
  271. }
  272.  
  273. /* rmbquote - read macro for '`' */
  274. NODE *rmbquote(args)
  275.   NODE *args;
  276. {
  277.     NODE ***oldstk,*fptr,*mch,*val;
  278.  
  279.     /* create a new stack frame */
  280.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  281.  
  282.     /* get the file and macro character */
  283.     fptr = xlgetfile(&args);
  284.     mch = xlmatch(INT,&args);
  285.     xllastarg(args);
  286.  
  287.     /* make the return value */
  288.     val = consa(NIL);
  289.     rplaca(val,pquote(fptr,s_bquote));
  290.  
  291.     /* restore the previous stack frame */
  292.     xlstack = oldstk;
  293.  
  294.     /* return the value */
  295.     return (val);
  296. }
  297.  
  298. /* rmcomma - read macro for ',' */
  299. NODE *rmcomma(args)
  300.   NODE *args;
  301. {
  302.     NODE ***oldstk,*fptr,*mch,*val,*sym;
  303.  
  304.     /* create a new stack frame */
  305.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  306.  
  307.     /* get the file and macro character */
  308.     fptr = xlgetfile(&args);
  309.     mch = xlmatch(INT,&args);
  310.     xllastarg(args);
  311.  
  312.     /* check the next character */
  313.     if (xlpeek(fptr) == '@') {
  314.     sym = s_comat;
  315.     xlgetc(fptr);
  316.     }
  317.     else
  318.     sym = s_comma;
  319.  
  320.     /* make the return value */
  321.     val = consa(NIL);
  322.     rplaca(val,pquote(fptr,sym));
  323.  
  324.     /* restore the previous stack frame */
  325.     xlstack = oldstk;
  326.  
  327.     /* return the value */
  328.     return (val);
  329. }
  330.  
  331. /* rmlpar - read macro for '(' */
  332. NODE *rmlpar(args)
  333.   NODE *args;
  334. {
  335.     NODE ***oldstk,*fptr,*mch,*val;
  336.  
  337.     /* create a new stack frame */
  338.     oldstk = xlsave(&fptr,&mch,&val,NULL);
  339.  
  340.     /* get the file and macro character */
  341.     fptr = xlgetfile(&args);
  342.     mch = xlmatch(INT,&args);
  343.     xllastarg(args);
  344.  
  345.     /* make the return value */
  346.     val = consa(NIL);
  347.     rplaca(val,plist(fptr));
  348.  
  349.     /* restore the previous stack frame */
  350.     xlstack = oldstk;
  351.  
  352.     /* return the value */
  353.     return (val);
  354. }
  355.  
  356. /* rmrpar - read macro for ')' */
  357. NODE *rmrpar(args)
  358.   NODE *args;
  359. {
  360.     xlfail("misplaced right paren");
  361. }
  362.  
  363. /* rmsemi - read macro for ';' */
  364. NODE *rmsemi(args)
  365.   NODE *args;
  366. {
  367.     NODE ***oldstk,*fptr,*mch;
  368.     int ch;
  369.  
  370.     /* create a new stack frame */
  371.     oldstk = xlsave(&fptr,&mch,NULL);
  372.  
  373.     /* get the file and macro character */
  374.     fptr = xlgetfile(&args);
  375.     mch = xlmatch(INT,&args);
  376.     xllastarg(args);
  377.  
  378.     /* skip to end of line */
  379.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
  380.     ;
  381.  
  382.     /* restore the previous stack frame */
  383.     xlstack = oldstk;
  384.  
  385.     /* return nil (nothing read) */
  386.     return (NIL);
  387. }
  388.  
  389. /* phexnumber - parse a hexidecimal number */
  390. LOCAL NODE *phexnumber(fptr)
  391.   NODE *fptr;
  392. {
  393.     long num;
  394.     int ch;
  395.     
  396.     num = 0L;
  397.     while ((ch = xlpeek(fptr)) != EOF) {
  398.     if (islower(ch)) ch = toupper(ch);
  399.     if (!isdigit(ch) && !(ch >= 'A' && ch <= 'F'))
  400.         break;
  401.     xlgetc(fptr);
  402.     num = num * 16L + (long)(ch <= '9' ? ch - '0' : ch - 'A' + 10);
  403.     }
  404.     return (cvfixnum((FIXNUM)num));
  405. }
  406.  
  407. /* plist - parse a list */
  408. LOCAL NODE *plist(fptr)
  409.   NODE *fptr;
  410. {
  411.     NODE ***oldstk,*val,*expr,*lastnptr;
  412.     NODE *nptr = NIL;
  413.     int ch;
  414.  
  415.     /* create a new stack frame */
  416.     oldstk = xlsave(&val,&expr,NULL);
  417.  
  418.     /* increase the paren nesting level */
  419.     ++xlplevel;
  420.  
  421.     /* keep appending nodes until a closing paren is found */
  422.     lastnptr = NIL;
  423.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr)
  424.  
  425.     /* get the next expression */
  426.     switch (readone(fptr,&expr)) {
  427.     case EOF:
  428.         badeof(fptr);
  429.     case TRUE:
  430.  
  431.         /* check for a dotted tail */
  432.         if (expr == s_dot) {
  433.  
  434.         /* make sure there's a node */
  435.         if (lastnptr == NIL)
  436.             xlfail("invalid dotted pair");
  437.  
  438.         /* parse the expression after the dot */
  439.         if (!xlread(fptr,&expr,TRUE))
  440.             badeof(fptr);
  441.         rplacd(lastnptr,expr);
  442.  
  443.         /* make sure its followed by a close paren */
  444.         if (nextch(fptr) != ')')
  445.             xlfail("invalid dotted pair");
  446.  
  447.         /* done with this list */
  448.         break;
  449.         }
  450.  
  451.         /* otherwise, handle a normal list element */
  452.         else {
  453.         nptr = consa(expr);
  454.         if (lastnptr == NIL)
  455.             val = nptr;
  456.         else
  457.             rplacd(lastnptr,nptr);
  458.         }
  459.         break;
  460.     }
  461.  
  462.     /* skip the closing paren */
  463.     xlgetc(fptr);
  464.  
  465.     /* decrease the paren nesting level */
  466.     --xlplevel;
  467.  
  468.     /* restore the previous stack frame */
  469.     xlstack = oldstk;
  470.  
  471.     /* return successfully */
  472.     return (val);
  473. }
  474.  
  475. /* pvector - parse a vector */
  476. LOCAL NODE *pvector(fptr)
  477.   NODE *fptr;
  478. {
  479.     NODE ***oldstk,*list,*expr,*val,*lastnptr;
  480.     NODE *nptr = NIL;
  481.     int len,ch,i;
  482.  
  483.     /* create a new stack frame */
  484.     oldstk = xlsave(&list,&expr,NULL);
  485.  
  486.     /* keep appending nodes until a closing paren is found */
  487.     lastnptr = NIL; len = 0;
  488.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
  489.  
  490.     /* check for end of file */
  491.     if (ch == EOF)
  492.         badeof(fptr);
  493.  
  494.     /* get the next expression */
  495.     switch (readone(fptr,&expr)) {
  496.     case EOF:
  497.         badeof(fptr);
  498.     case TRUE:
  499.         nptr = consa(expr);
  500.         if (lastnptr == NIL)
  501.         list = nptr;
  502.         else
  503.         rplacd(lastnptr,nptr);
  504.         len++;
  505.         break;
  506.     }
  507.     }
  508.  
  509.     /* skip the closing paren */
  510.     xlgetc(fptr);
  511.  
  512.     /* make a vector of the appropriate length */
  513.     val = newvector(len);
  514.  
  515.     /* copy the list into the vector */
  516.     for (i = 0; i < len; ++i, list = cdr(list))
  517.     setelement(val,i,car(list));
  518.  
  519.     /* restore the previous stack frame */
  520.     xlstack = oldstk;
  521.  
  522.     /* return successfully */
  523.     return (val);
  524. }
  525.  
  526. /* pquote - parse a quoted expression */
  527. LOCAL NODE *pquote(fptr,sym)
  528.   NODE *fptr,*sym;
  529. {
  530.     NODE ***oldstk,*val,*p;
  531.  
  532.     /* create a new stack frame */
  533.     oldstk = xlsave(&val,NULL);
  534.  
  535.     /* allocate two nodes */
  536.     val = consa(sym);
  537.     rplacd(val,consa(NIL));
  538.  
  539.     /* initialize the second to point to the quoted expression */
  540.     if (!xlread(fptr,&p,TRUE))
  541.     badeof(fptr);
  542.     rplaca(cdr(val),p);
  543.  
  544.     /* restore the previous stack frame */
  545.     xlstack = oldstk;
  546.  
  547.     /* return the quoted expression */
  548.     return (val);
  549. }
  550.  
  551. /* pname - parse a symbol name */
  552. LOCAL NODE *pname(fptr,ch)
  553.   NODE *fptr; int ch;
  554. {
  555.     NODE *val,*type;
  556.     int i;
  557.  
  558.     /* get symbol name */
  559.     for (i = 0; ; xlgetc(fptr)) {
  560.     if (i < STRMAX)
  561.         buf[i++] = (islower(ch) ? toupper(ch) : ch);
  562.     if ((ch = xlpeek(fptr)) == EOF ||
  563.         ((type = tentry(ch)) != k_const &&
  564.              !(consp(type) && car(type) == k_nmacro)))
  565.         break;
  566.     }
  567.     buf[i] = 0;
  568.  
  569.     /* check for a number or enter the symbol into the oblist */
  570.     return (isnumber(buf,&val) ? val : xlenter(buf,DYNAMIC));
  571. }
  572.  
  573. /* tentry - get a readtable entry */
  574. LOCAL NODE *tentry(ch)
  575.   int ch;
  576. {
  577.     NODE *rtable;
  578.     rtable = getvalue(s_rtable);
  579.     if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
  580.     return (NIL);
  581.     return (getelement(rtable,ch));
  582. }
  583.  
  584. /* nextch - look at the next non-blank character */
  585. LOCAL int nextch(fptr)
  586.   NODE *fptr;
  587. {
  588.     int ch;
  589.  
  590.     /* return and save the next non-blank character */
  591.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  592.     xlgetc(fptr);
  593.     return (ch);
  594. }
  595.  
  596. /* checkeof - get a character and check for end of file */
  597. LOCAL int checkeof(fptr)
  598.   NODE *fptr;
  599. {
  600.     int ch;
  601.  
  602.     if ((ch = xlgetc(fptr)) == EOF)
  603.     badeof(fptr);
  604.     return (ch);
  605. }
  606.  
  607. /* badeof - unexpected eof */
  608. LOCAL badeof(fptr)
  609.   NODE *fptr;
  610. {
  611.     xlgetc(fptr);
  612.     xlfail("unexpected EOF");
  613. }
  614.  
  615. /* isnumber - check if this string is a number */
  616. int isnumber(str,pval)
  617.   char *str; NODE **pval;
  618. {
  619.     int dl,dr;
  620.     char *p;
  621.  
  622.     /* initialize */
  623.     p = str; dl = dr = 0;
  624.  
  625.     /* check for a sign */
  626.     if (*p == '+' || *p == '-')
  627.     p++;
  628.  
  629.     /* check for a string of digits */
  630.     while (isdigit(*p))
  631.     p++, dl++;
  632.  
  633.     /* check for a decimal point */
  634.     if (*p == '.') {
  635.     p++;
  636.     while (isdigit(*p))
  637.         p++, dr++;
  638.     }
  639.  
  640.     /* check for an exponent */
  641.     if ((dl || dr) && *p == 'E') {
  642.     p++;
  643.  
  644.     /* check for a sign */
  645.     if (*p == '+' || *p == '-')
  646.         p++;
  647.  
  648.     /* check for a string of digits */
  649.     while (isdigit(*p))
  650.         p++, dr++;
  651.     }
  652.  
  653.     /* make sure there was at least one digit and this is the end */
  654.     if ((dl == 0 && dr == 0) || *p)
  655.     return (FALSE);
  656.  
  657.     /* convert the string to an integer and return successfully */
  658.     if (*str == '+') ++str;
  659.     if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
  660.     *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
  661.     return (TRUE);
  662. }
  663.  
  664. /* defmacro - define a read macro */
  665. defmacro(ch,type,fun)
  666.   int ch; NODE *type,*(*fun)();
  667. {
  668.     NODE *p;
  669.     p = consa(type);
  670.     setelement(getvalue(s_rtable),ch,p);
  671.     rplacd(p,cvsubr(fun,SUBR));
  672. }
  673.  
  674. /* callmacro - call a read macro */
  675. NODE *callmacro(fptr,ch)
  676.   NODE *fptr; int ch;
  677. {
  678.     NODE ***oldstk,*fun,*args,*val;
  679.  
  680.     /* create a new stack frame */
  681.     oldstk = xlsave(&fun,&args,NULL);
  682.  
  683.     /* get the macro function */
  684.     fun = cdr(getelement(getvalue(s_rtable),ch));
  685.  
  686.     /* create the argument list */
  687.     args = consa(fptr);
  688.     rplacd(args,consa(NIL));
  689.     rplaca(cdr(args),cvfixnum((FIXNUM)ch));
  690.  
  691.     /* apply the macro function to the arguments */
  692.     val = xlapply(fun,args);
  693.  
  694.     /* restore the previous stack frame */
  695.     xlstack = oldstk;
  696.  
  697.     /* return the result */
  698.     return (val);
  699. }
  700.  
  701. /* needsextension - determine if a filename needs an extension */
  702. int needsextension(name)
  703.   char *name;
  704. {
  705.     while (*name)
  706.     if (*name++ == '.')
  707.         return (FALSE);
  708.     return (TRUE);
  709. }
  710.  
  711. /* xlrinit - initialize the reader */
  712. xlrinit()
  713. {
  714.     NODE *rtable;
  715.     char *p;
  716.     int ch;
  717.  
  718.     /* create the read table */
  719.     rtable = newvector(256);
  720.     setvalue(s_rtable,rtable);
  721.  
  722.     /* initialize the readtable */
  723.     for (p = WSPACE; ch = *p++; )
  724.     setelement(rtable,ch,k_wspace);
  725.     for (p = CONST1; ch = *p++; )
  726.     setelement(rtable,ch,k_const);
  727.     for (p = CONST2; ch = *p++; )
  728.     setelement(rtable,ch,k_const);
  729.  
  730.     /* install the read macros */
  731.     defmacro('#', k_nmacro,rmhash);
  732.     defmacro('\'',k_tmacro,rmquote);
  733.     defmacro('"', k_tmacro,rmdquote);
  734.     defmacro('`', k_tmacro,rmbquote);
  735.     defmacro(',', k_tmacro,rmcomma);
  736.     defmacro('(', k_tmacro,rmlpar);
  737.     defmacro(')', k_tmacro,rmrpar);
  738.     defmacro(';', k_tmacro,rmsemi);
  739. }
  740.  
  741.  
  742.